home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / cmpnew / cmpmain.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-03  |  19.5 KB  |  508 lines
  1. ;;; CMPMAIN  Compiler main program.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. ;;;        **** Caution ****
  8. ;;;    This file is machine/OS dependant.
  9. ;;;        *****************
  10.  
  11.  
  12. (in-package 'compiler)
  13.  
  14.  
  15. (export '(*compile-print* *compile-verbose*))
  16.  
  17.  
  18. (defvar *compiler-in-use* nil)
  19. (defvar *compiler-input*)
  20. (defvar *compiler-output1*)
  21. (defvar *compiler-output2*)
  22. (defvar *compiler-output-data*)
  23.  
  24. (defvar *error-p* nil)
  25.  
  26. (defvar *compile-print* nil)
  27. (defvar *compile-verbose* t)
  28.  
  29. #+(and bsd (not seq))(pushnew 'buggy-cc *features*)
  30.  
  31.  
  32. (defmacro get-output-pathname (file ext)
  33.   `(make-pathname :directory (or (and (not (null ,file))
  34.                                       (not (eq ,file t))
  35.                                       (pathname-directory ,file))
  36.                                  dir)
  37.                   :name (or (and (not (null ,file))
  38.                                  (not (eq ,file t))
  39.                                  (pathname-name ,file))
  40.                             name)
  41.                   :type ,ext))
  42.  
  43. #+unix
  44. (defun safe-system (string)
  45.   (let ((result (system string)))
  46.     (unless (zerop result)
  47.       (cerror "Continues anyway."
  48.               "(SYSTEM ~S) returned a non-zero value ~D."
  49.               string
  50.               result)
  51.       (setq *error-p* t))
  52.     (values result)))
  53.  
  54. (defun compile-file1 (input-pathname
  55.                       &key (output-file input-pathname)
  56.                            #+aosvs (fasl-file t)
  57.                            #+unix (o-file t)
  58.                            (c-file nil)
  59.                            (h-file nil)
  60.                            (data-file nil)
  61.                            #+aosvs (ob-file nil)
  62.                            (system-p nil)
  63.                            (load nil)
  64.                       &aux (*standard-output* *standard-output*)
  65.                            (*error-output* *error-output*)
  66.                            (*compiler-in-use* *compiler-in-use*)
  67.                            (*package* *package*)
  68.                            (*error-count* 0))
  69.  
  70.   (cond (*compiler-in-use*
  71.          (format t "~&The compiler was called recursively.~%~
  72. Cannot compile ~a."
  73.                  (namestring (merge-pathnames input-pathname #".lsp")))
  74.          (setq *error-p* t)
  75.          (return-from compile-file1 (values)))
  76.         (t (setq *error-p* nil)
  77.            (setq *compiler-in-use* t)))  
  78.  
  79.   (unless (probe-file (merge-pathnames input-pathname #".lsp"))
  80.     (format t "~&The source file ~a is not found.~%"
  81.             (namestring (merge-pathnames input-pathname #".lsp")))
  82.     (setq *error-p* t)
  83.     (return-from compile-file1 (values)))
  84.  
  85.   (when *compile-verbose*
  86.     (format t "~&Compiling ~a."
  87.             (namestring (merge-pathnames input-pathname #".lsp"))))
  88.  
  89.   (let* ((eof (cons nil nil))
  90.          (dir (or (and (not (null output-file))
  91.                        (pathname-directory output-file))
  92.                   (pathname-directory input-pathname)))
  93.  
  94.          (name (or (and (not (null output-file))
  95.                         (pathname-name output-file))
  96.                    (pathname-name input-pathname)))
  97.  
  98.          #+aosvs (fasl-pathname (get-output-pathname fasl-file "fasl"))
  99.          #+unix (o-pathname (get-output-pathname o-file "o"))
  100.          (c-pathname (get-output-pathname c-file "c"))
  101.          #+buggy-cc
  102.          (s-pathname (merge-pathnames ".s" (pathname-name c-pathname)))
  103.          (h-pathname (get-output-pathname h-file "h"))
  104.          (data-pathname (get-output-pathname data-file "data"))
  105.          #+aosvs (ob-pathname (get-output-pathname ob-file "ob"))
  106.          )
  107.  
  108.     (init-env)
  109.  
  110.     (when (probe-file #+unix "./cmpinit.lsp" #+aosvs "=cmpinit.lsp")
  111.       (load #+unix "./cmpinit.lsp" #+aosvs "=cmpinit.lsp"
  112.             :verbose *compile-verbose*))
  113.  
  114.     (with-open-file (*compiler-output-data*
  115.                      #+unix data-pathname #+aosvs fasl-pathname
  116.                      :direction :output)
  117.       (wt-data-begin)
  118.  
  119.       (with-open-file
  120.           (*compiler-input* (merge-pathnames input-pathname #".lsp"))
  121.         (let* ((rtb *readtable*)
  122.                (prev (and (eq (get-macro-character #\# rtb)
  123.                               (get-macro-character
  124.                                 #\# (si:standard-readtable)))
  125.                           (get-dispatch-macro-character #\# #\, rtb))))
  126.           (if (and prev (eq prev (get-dispatch-macro-character
  127.                                    #\# #\, (si:standard-readtable))))
  128.               (set-dispatch-macro-character #\# #\,
  129.                 'si:sharp-comma-reader-for-compiler rtb)
  130.               (setq prev nil))
  131.           (unwind-protect
  132.             (do ((form (read *compiler-input* nil eof)
  133.                        (read *compiler-input* nil eof)))
  134.                 ((eq form eof))
  135.               (t1expr form))
  136.             (when prev (set-dispatch-macro-character #\# #\, prev rtb)))))
  137.  
  138.       (when (zerop *error-count*)
  139.         (when *compile-verbose* (format t "~&End of Pass 1.  "))
  140.         (compiler-pass2 c-pathname h-pathname system-p
  141.                         (if system-p
  142.                             #-aosvs (pathname-name input-pathname)
  143.                             #+aosvs (string-downcase
  144.                                      (pathname-name input-pathname))
  145.                             "code")))
  146.  
  147.       (wt-data-end)
  148.  
  149.       ) ;;; *compiler-output-data* closed.
  150.  
  151.     (init-env)
  152.  
  153.     (if (zerop *error-count*)
  154.  
  155.         #+aosvs
  156.         (progn
  157.           (when *compile-verbose* (format t "~&End of Pass 2.  "))
  158.           (when data-file
  159.             (with-open-file (in fasl-pathname)
  160.               (with-open-file (out data-pathname :direction :output)
  161.                 (si:copy-stream in out))))
  162.           (cond ((or fasl-file ob-file)
  163.                  (compiler-cc c-pathname ob-pathname)
  164.                  (cond ((probe-file ob-pathname)
  165.                         (when fasl-file
  166.                               (compiler-build ob-pathname fasl-pathname)
  167.                               (when load (load fasl-pathname)))
  168.                         (unless ob-file (delete-file ob-pathname))
  169.                         (when *compile-verbose*
  170.                               (print-compiler-info)
  171.                               (format t "~&Finished compiling ~a."
  172.                                       (namestring (merge-pathnames
  173.                                                    input-pathname #".lsp")))))
  174.                        (t (format t "~&Your C compiler failed to compile the intermediate file.~%")
  175.                           (setq *error-p* t))))
  176.                 (*compile-verbose*
  177.                  (print-compiler-info)
  178.                  (format t "~&Finished compiling ~a."
  179.                          (namestring (merge-pathnames
  180.                                       input-pathname #".lsp")))))
  181.           (unless c-file (delete-file c-pathname))
  182.           (unless h-file (delete-file h-pathname))
  183.           (unless fasl-file (delete-file fasl-pathname)))
  184.  
  185.         #+unix
  186.         (progn
  187.           (when *compile-verbose* (format t "~&End of Pass 2.  "))
  188.           (cond (o-file
  189.                  (compiler-cc c-pathname o-pathname #+buggy-cc s-pathname)
  190.                  (cond ((probe-file o-pathname)
  191.                         (compiler-build o-pathname data-pathname)
  192.                         (when load (load o-pathname))
  193.                         #+buggy-cc (delete-file s-pathname)
  194.                         (when *compile-verbose*
  195.                               (print-compiler-info)
  196.                               (format t "~&Finished compiling ~a."
  197.                                       (namestring (merge-pathnames
  198.                                                    input-pathname #".lsp")))))
  199.                        (t #+buggy-cc (when (probe-file s-pathname)
  200.                                            (delete-file s-pathname))
  201.                           (format t "~&Your C compiler failed to compile the intermediate file.~%")
  202.                           (setq *error-p* t))))
  203.                  (*compile-verbose*
  204.                   (print-compiler-info)
  205.                   (format t "~&Finished compiling ~a."
  206.                           (namestring (merge-pathnames
  207.                                        input-pathname #".lsp")))))
  208.           (unless c-file (delete-file c-pathname))
  209.           (unless h-file (delete-file h-pathname))
  210.           (unless data-file (delete-file data-pathname)))
  211.  
  212.         (progn
  213.           (when (probe-file c-pathname) (delete-file c-pathname))
  214.           (when (probe-file h-pathname) (delete-file h-pathname))
  215.           #+aosvs
  216.           (when (probe-file fasl-pathname) (delete-file fasl-pathname))
  217.           #+unix
  218.           (when (probe-file data-pathname) (delete-file data-pathname))
  219.           (format t "~&No FASL generated.~%")
  220.           (setq *error-p* t))
  221.         ))
  222.   (values))
  223.  
  224. (defun compile1 (name &optional (def nil supplied-p)
  225.                       &aux form gazonk-name
  226.                       #+aosvs fasl-pathname
  227.                       #+unix data-pathname
  228.                       (*compiler-in-use* *compiler-in-use*)
  229.                       (*standard-output* *standard-output*)
  230.                       (*error-output* *error-output*)
  231.                       (*package* *package*)
  232.                       (*compile-print* nil)
  233.                       (*error-count* 0))
  234.  
  235.   (unless (symbolp name) (error "~s is not a symbol." name))
  236.  
  237.   (cond (*compiler-in-use*
  238.          (format t "~&The compiler was called recursively.~%~
  239. Cannot compile ~s." name)
  240.          (setq *error-p* t)
  241.          (return-from compile1))
  242.         (t (setq *error-p* nil)
  243.            (setq *compiler-in-use* t)))
  244.  
  245.   (cond ((and supplied-p (not (null def)))
  246.          (unless (and (consp def) (eq (car def) 'lambda))
  247.                  (error "~s is invalid lambda expression." def))
  248.          (setq form (if name
  249.                         `(defun ,name ,@(cdr def))
  250.                         `(set 'gazonk #',def))))
  251.         ((and (consp (setq def (symbol-function name)))
  252.               (eq (car def) 'lambda-block)
  253.               (consp (cdr def)))
  254.          (setq form `(defun ,name ,@(cddr def))))
  255.         (t (error "No lambda expression is assigned to the symbol ~s." name)))
  256.  
  257.   (dotimes (n 1000
  258.               (progn
  259.                 (format t "~&The name space for GAZONK files exhausted.~%~
  260. Delete one of your GAZONK*** files before compiling ~s." name)
  261.                 (setq *error-p* t)
  262.                 (return-from compile1 (values))))
  263.     (setq gazonk-name (format nil "gazonk~3,'0d" n))
  264.     #+aosvs
  265.     (setq fasl-pathname (make-pathname :name gazonk-name :type "fasl"))
  266.     #+unix
  267.     (setq data-pathname (make-pathname :name gazonk-name :type "data"))
  268.     (unless (probe-file #+aosvs fasl-pathname
  269.                         #+unix data-pathname)
  270.       (return)))
  271.  
  272.   (let ((c-pathname (make-pathname :name gazonk-name :type "c"))
  273.         #+buggy-cc
  274.         (s-pathname (make-pathname :name gazonk-name :type "s"))
  275.         (h-pathname (make-pathname :name gazonk-name :type "h"))
  276.         #+unix (o-pathname (make-pathname :name gazonk-name :type "o"))
  277.         #+aosvs (ob-pathname (make-pathname :name gazonk-name :type "ob")))
  278.  
  279.     (init-env)
  280.  
  281.     (with-open-file (*compiler-output-data*
  282.                      #+unix data-pathname #+aosvs fasl-pathname
  283.                      :direction :output)
  284.       (wt-data-begin)
  285.  
  286.       (t1expr form)
  287.  
  288.       (when (zerop *error-count*)
  289.         (when *compile-verbose* (format t "~&End of Pass 1.  "))
  290.         (compiler-pass2 c-pathname h-pathname nil "code"))
  291.  
  292.       (wt-data-end)
  293.       ) ;;; *compiler-output-data* closed.
  294.  
  295.     (init-env)
  296.  
  297.     (if (zerop *error-count*)
  298.         #+aosvs
  299.         (progn
  300.           (when *compile-verbose* (format t "~&End of Pass 2.  "))
  301.           (compiler-cc c-pathname ob-pathname)
  302.           (delete-file c-pathname)
  303.           (delete-file h-pathname)
  304.           (cond ((probe-file ob-pathname)
  305.                  (compiler-build ob-pathname fasl-pathname)
  306.                  (delete-file ob-pathname)
  307.                  (load fasl-pathname :verbose nil)
  308.                  (when *compile-verbose* (print-compiler-info))
  309.                  (delete-file fasl-pathname)
  310.                  (or name (symbol-value 'gazonk)))
  311.                 (t (delete-file fasl-pathname)
  312.                    (format t "~&Your C compiler failed to compile the intermediate code for ~s.~%" name)
  313.                    (setq *error-p* t)
  314.                    name)))
  315.  
  316.         #+unix
  317.         (progn
  318.           (when *compile-verbose* (format t "~&End of Pass 2.  "))
  319.           (compiler-cc c-pathname o-pathname #+buggy-cc s-pathname)
  320.           (delete-file c-pathname)
  321.           (delete-file h-pathname)
  322.           #+buggy-cc (when (probe-file s-pathname) (delete-file s-pathname))
  323.           (cond ((probe-file o-pathname)
  324.                  (compiler-build o-pathname data-pathname)
  325.                  (load o-pathname :verbose nil)
  326.                  (when *compile-verbose* (print-compiler-info))
  327.                  (delete-file o-pathname)
  328.                  (delete-file data-pathname)
  329.                  (or name (symbol-value 'gazonk)))
  330.                 (t (delete-file data-pathname)
  331.                    (format t "~&Your C compiler failed to compile the intermediate code for ~s.~%" name)
  332.                    (setq *error-p* t)
  333.                    name)))
  334.  
  335.         (progn
  336.           (when (probe-file c-pathname) (delete-file c-pathname))
  337.           (when (probe-file h-pathname) (delete-file h-pathname))
  338.           #+aosvs
  339.           (when (probe-file fasl-pathname) (delete-file fasl-pathname))
  340.           #+unix
  341.           (when (probe-file data-pathname) (delete-file data-pathname))
  342.           (format t "~&Failed to compile ~s.~%" name)
  343.           (setq *error-p* t)
  344.           name))))
  345.  
  346. (defvar *disassembled-form* '(defun gazonk ()))
  347.  
  348. (defun disassemble1 (&optional (thing nil)
  349.                      &key (h-file nil) (data-file nil)
  350.                      &aux def
  351.                      (*compiler-in-use* *compiler-in-use*))
  352.  (cond (*compiler-in-use*
  353.         (format t "~&The compiler was called recursively.~%~
  354. Cannot disassemble ~a." thing)
  355.         (setq *error-p* t)
  356.         (return-from disassemble1))
  357.        (t (setq *error-p* nil)
  358.           (setq *compiler-in-use* t)))
  359.  
  360.   (cond ((null thing))
  361.         ((symbolp thing)
  362.          (setq def (symbol-function thing))
  363.          (cond ((macro-function thing)
  364.                 (error
  365.                  "Associated with the symbol ~s is a macro, not a function."
  366.                  thing))
  367.                ((not (and (consp def)
  368.                           (eq (car def) 'lambda-block)
  369.                           (consp (cdr def))))
  370.                 (error "The function object ~s cannot be disassembled." def))
  371.                (t (setq *disassembled-form* `(defun ,thing ,@(cddr def))))))
  372.         ((and (consp thing) (eq (car thing) 'lambda))
  373.          (setq *disassembled-form* `(defun gazonk ,@(cdr thing))))
  374.         (t (setq *disassembled-form* thing)))
  375.  
  376.   (let ((*compiler-output1* *standard-output*)
  377.         (*compiler-output2* (if h-file
  378.                                 (open h-file :direction :output)
  379.                                 (make-broadcast-stream)))
  380.         (*compiler-output-data* (if data-file
  381.                                     (open data-file :direction :output)
  382.                                     (make-broadcast-stream)))
  383.         (*error-count* 0))
  384.        (unwind-protect
  385.         (progn
  386.          (init-env)
  387.          (wt-data-begin)
  388.  
  389.          (t1expr *disassembled-form*)
  390.  
  391.          (cond ((zerop *error-count*)
  392.                 (catch *cmperr-tag* (ctop-write "code")))
  393.                (t (setq *error-p* t)))
  394.  
  395.          (wt-data-end)
  396.          (init-env)
  397.          )
  398.         (when h-file (close *compiler-output2*))
  399.         (when data-file (close *compiler-output-data*))))
  400.  
  401.   (values)
  402.   )
  403.  
  404. (defun compiler-pass2 (c-pathname h-pathname system-p init-name)
  405.   (with-open-file (*compiler-output1* c-pathname :direction :output)
  406.     (with-open-file (*compiler-output2* h-pathname :direction :output)
  407.       (when system-p
  408.         (wt-nl1 "/* (C) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. */")
  409.         (wt-h "/* (C) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. */"))
  410.       (wt-nl1 "#include <cmpinclude.h>")
  411.       (wt-nl1 "#include \""
  412.               #-aosvs (namestring h-pathname)
  413.               #+aosvs (string-downcase (namestring h-pathname))
  414.               "\"")
  415.  
  416.       (catch *cmperr-tag* (ctop-write init-name))
  417.  
  418.       (terpri *compiler-output1*)
  419.       (terpri *compiler-output2*))))
  420.  
  421. #+aosvs
  422. (defun compiler-cc (c-pathname ob-pathname)
  423.   (process "cc.pr" ; or ":usr:dgc:cc.pr"
  424.            (format nil "cc/opt=~d/noextl/e=@null/o=~a,~a"
  425.                    *speed* (namestring ob-pathname) (namestring c-pathname))
  426.            :block t :ioc t)
  427.   (when (string/= (princ (last-termination-message)) "") (terpri)))
  428.  
  429. #+unix
  430. (defun compiler-cc (c-pathname o-pathname #+buggy-cc s-pathname)
  431.   #+e15
  432.   (let ((C (namestring
  433.             (make-pathname
  434.              :directory (pathname-directory c-pathname)
  435.              :name (pathname-name c-pathname)
  436.              :type "C")))
  437.         (H (namestring
  438.             (make-pathname
  439.              :directory (pathname-directory h-pathname)
  440.              :name (pathname-name h-pathname)
  441.              :type "H"))))
  442.     (system (format nil "mv ~A ~A" (namestring c-pathname) C))
  443.     (system (format nil "mv ~A ~A" (namestring h-pathname) H))
  444.     (system (format nil "~Atrans < ~A > ~A"
  445.               (namestring si:*system-directory*) C (namestring c-pathname)))
  446.     (system (format nil "~Atrans < ~A > ~A"
  447.               (namestring si:*system-directory*) H (namestring h-pathname)))
  448.     (delete-file C)
  449.     (delete-file H))
  450.  
  451.   (safe-system
  452.     (format nil
  453.             #-(or system-v e15 dgux)
  454.               #+buggy-cc
  455.                 #+vax"cc ~@[~*-O ~]-S -I. -w ~a ; as -J -W -o ~A ~A"
  456.                 #-vax"cc ~@[~*-O ~]-S -I. -w ~a ; as -J -o ~A ~A"
  457.               #-buggy-cc "cc ~@[~*-O ~]-c -I. -w ~a"
  458.             #+(or system-v e15 dgux) "cc ~@[~*-O ~]-c -I. ~a 2> /dev/null"
  459.             (if (or (= *speed* 2) (= *speed* 3)) t nil)
  460.             (namestring c-pathname)
  461.             #+buggy-cc (namestring o-pathname)
  462.             #+buggy-cc (namestring s-pathname)
  463.             ))
  464.   #-buggy-cc
  465.   (let ((cname (pathname-name c-pathname))
  466.         (odir (pathname-directory o-pathname))
  467.         (oname (pathname-name o-pathname)))
  468.     (unless (and (equalp (truename "./")
  469.                          (truename (make-pathname :directory odir)))
  470.                  (equal cname oname))
  471.             (safe-system
  472.              (format nil "mv ~A.o ~A" cname (namestring o-pathname))))))
  473.  
  474. #+aosvs
  475. (defun compiler-build (ob-pathname fasl-pathname)
  476.   (process
  477.     (namestring
  478.       (merge-pathnames si:*system-directory* "build_fasl.pr"))
  479.     (si:string-concatenate
  480.       "build_fasl," (namestring fasl-pathname) ","
  481.       (namestring ob-pathname))
  482.     :block t :ioc t)
  483.   (when (string/= (last-termination-message) "")
  484.     (setq *error-p* t)
  485.     (princ (last-termination-message))
  486.     (terpri)))
  487.  
  488. #+unix
  489. (defun compiler-build (o-pathname data-pathname)
  490.   #+(and system-v (not e15))
  491.   (safe-system (format nil "echo \"\\000\\000\\000\\000\" >> ~A"
  492.                        (namestring o-pathname)))
  493.   (when (probe-file o-pathname)
  494.     (safe-system (format nil #-dgux "cat ~A >> ~A"
  495.                              #+dgux "~Abuild_o ~A ~A"
  496.                              #+dgux (namestring si:*system-directory*)
  497.                              (namestring data-pathname)
  498.                              (namestring o-pathname)))))
  499.  
  500. (defun print-compiler-info ()
  501.   (format t "~&OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%"
  502.           (cond ((null *compiler-check-args*) 0)
  503.                 ((null *safe-compile*) 1)
  504.                 ((null *compiler-push-events*) 2)
  505.                 (t 3))
  506.           *safe-compile* *space* *speed*))
  507.  
  508.